functor Adce (S : ADCE_STRUCTS) : ADCE =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
  
  val changed = ref false
  
  structure CounterSet =
  BinarySetFn (struct
                 type ord_key = Counter.t
                 val compare = Counter.compare
               end)
               
  structure VarSet =
  BinarySetFn (struct
                 type ord_key = Id.t
                 val compare = Id.compare
               end)
               
  structure LiveCounterSet :
  sig
    type t
    
    val add : t * Counter.t -> t
    val delete : t * Counter.t -> t
    val empty : unit -> t
    val isEmpty : t -> bool
    val member : t * Counter.t -> bool
  end =
  struct
    type t = CounterSet.set
    
    fun add (set, id) = CounterSet.add (set, id)    
    fun empty () = CounterSet.empty
    val isEmpty = CounterSet.isEmpty
    fun member (set, id) = CounterSet.member (set, id)
    fun delete (set, id) =
        if member (set, id)
        then CounterSet.delete (set, id)
        else set
  end
  
  structure LiveVarSet :
  sig
    type t
    
    val add : Id.t -> unit
    val delete : Id.t -> unit
    val empty : unit -> t
    val init : unit -> unit
    val isEmpty : unit -> bool
    val member : Id.t -> bool
  end =
  struct
    type t = VarSet.set ref
    
    val all = ref VarSet.empty
    
    fun init () = all := VarSet.empty
    fun add id = all := VarSet.add (!all, id)    
    fun empty () = ref VarSet.empty 
    fun isEmpty () = VarSet.isEmpty (!all)
    fun member id = VarSet.member (!all, id)
    fun delete (id) =
        if member (id)
        then all := VarSet.delete (!all, id)
        else ()
  end
  
  structure Cs = LiveCounterSet
  structure Vs = LiveVarSet
               
  val {get = liveCounter, set = setLiveCounter, destroy = destroyLiveCounter, ...} :
      {get : Counter.t -> bool, set : Counter.t * bool -> unit, destroy : unit -> unit} =
      Property.destGetSetOnce (Counter.plist, Property.initConst false)
      
  val {get = liveBlock, set = setLiveBlock, destroy = destroyLiveBlock, ...} :
      {get : Id.t -> bool, set : Id.t * bool -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst false)
      
  val {get = liveVar, set = setLiveVar, destroy = destroyLiveVar, ...} :
      {get : Id.t -> bool, set : Id.t * bool -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst false)
      
  val {get = jump, set = setJump, destroy = destroyJump, ...} :
      {get : Id.t -> Id.t option, set : Id.t * Id.t option -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst NONE)
   
  fun destroy () =
      (destroyLiveCounter ()
      ; destroyLiveBlock ()
      ; destroyLiveVar ()
      ; destroyJump ())
  
  fun annotateLiveStm (name, s) =
      let val counter = M.getLine s
      in  if liveCounter counter
          then ()
          else (if M.withSideEffects s
               then let val _ = debugPrint "set counter live in side effect stm\n"
                        val _ = setLiveCounter (counter, true)
                        val _ = debugPrint (String.concat ["the whole block is live due to side condition: ",
                                                           Id.toString name, "\n"])
                        val _ = setLiveBlock (name, true)
                        val _ = changed := true
                        val allUsedVars = M.uses s
                        val _ = List.app (fn x => setLiveVar (x, true)) allUsedVars
                    in  ()
                    end
               else ()
              ; if liveCounter counter
                then ()
                else let val dest = M.cookDest s
                     in  case dest
                          of NONE => ()
                           | SOME id =>
                             if liveVar id
                             then let val _ = debugPrint "set counter live in def stm\n"
                                      val _ = setLiveCounter (counter, true)
                                      val _ = debugPrint (String.concat ["the whole block is live due to def live: ",
                                                                         Id.toString name, "\n"])
                                      val _ = setLiveBlock (name, true)
                                      val _ = changed := true
                                      val allUsedVars = M.uses s
                                      val _ = List.app (fn x => setLiveVar (x, true)) allUsedVars
                                  in  ()
                                  end
                             else ()
                     end)
      end
  
  fun depend (name, cdg, getCdgName) =
      let val startNode = DiGraph.lookup (cdg, fn x => Id.equals (name, getCdgName x))
          val {get = visited, set = setVisited, destroy = destroyVisited, ...}
              = Property.destGetSet (DiGraph.Node.plist, Property.initConst false)
          fun dfs start =
              let val _ = setVisited (start, true)
                  val succs = DiGraph.Node.successors start
                  fun doSuccs succs =
                      case succs
                       of [] => false
                        | x :: xs =>
                          if (visited x)
                          then doSuccs xs
                          else (if liveBlock (getCdgName x)
                                then let val _ = debugPrint (String.concat ["found a dependent: ",
                                                                            Id.toString (getCdgName x), " <== ",
                                                                            Id.toString name, "\n"])
                                     in  true
                                     end
                                else (dfs x; doSuccs xs))
                  val b = doSuccs succs
              in  b
              end
          val b = dfs startNode
      in  b
      end
      
  fun annotateLiveTransfer (name, j, cdg, getCdgName) =
      case j
       of J.Jump _ => ()
        | J.If {line, value, truee, falsee} =>
          if liveCounter line
          then ()
          else if depend (name, cdg, getCdgName)
               then let val _ = debugPrint "set counter live in if branch\n"
                        val _ = setLiveCounter (line, true)
                        val _ = debugPrint (String.concat ["the whole block is live due to if branch: ",
                                                           Id.toString name, "\n"])
                        val _ = setLiveBlock (name, true)
                        val _ = List.app (fn x => setLiveVar (x, true)) (O.orig value)
                        val _ = changed := true
                    in  ()
                    end
               else ()
        | J.Return {line, value} =>
          if liveCounter line
          then ()
          else let val _ = debugPrint "set counter live in return\n"
                   val _ = setLiveCounter (line, true)
                   val _ = debugPrint (String.concat ["the whole block is live due to return: ",
                                                      Id.toString name, "\n"])
                   val _ = setLiveBlock (name, true)
                   val _ = List.app (fn x => setLiveVar (x, true)) (O.orig value)
                   val _ = changed := true
               in  ()
               end
         
  fun annotateLiveBlock (cdg, getCdgName, b) =
      case b
       of K.T {name,
               prop,
               stms,
               transfer,
               successors} =>
          let val _ = List.app (fn x => (annotateLiveStm (name, x))) stms 
              val _ = annotateLiveTransfer (name, transfer, cdg, getCdgName)
              val _ = ()
          in  ()
          end
  
  fun setLiveTransfer t =
      case t
       of J.If {line, value, truee, falsee} =>
          if liveCounter line
          then ()
          else let val _ = debugPrint "set counter live in if branch\n"
                   val _ = setLiveCounter (line, true)
                   val _ = changed := true
                   val _ = List.app (fn x => setLiveVar (x, true)) (O.orig value)
               in  ()
               end
        | J.Jump {line, label} => 
          if liveCounter line
          then ()
          else let val _ = setLiveCounter (line, true)
                   val _ = changed := true
               in  ()
               end
        | J.Return {line, value} =>
          if liveCounter line
          then ()
          else let val _ = setLiveCounter (line, true)
                   val _ = changed := true
                   val _ = List.app (fn x => setLiveVar (x, true)) (O.orig value)
               in  ()
               end
          
  fun setLiveBlockTransferOne b =
      case b
       of K.T {name,
               prop,
               stms,
               transfer,
               successors} =>
          let val isLive = liveBlock name          
          in  if isLive
              then setLiveTransfer transfer
              else ()
          end
          
  fun setLiveBlockTransfer blocks = List.app setLiveBlockTransferOne blocks
               
  fun annotateLiveBlocks (cdg, getCdgName, blocks) =
      List.app (fn x => annotateLiveBlock (cdg, getCdgName, x)) blocks 
        
  fun deleteStms ss =
      case ss
       of [] => []
        | x :: xs =>
          if liveCounter (M.getLine x)
          then x :: (deleteStms xs)
          else let val _ = debugPrint (String.concat ["now deleting: ", M.toString x, "\n"])
               in  deleteStms xs
               end
      
  fun deleteStmBlock b =
      case b
       of K.T {name,
               prop,
               stms,
               transfer,
               successors} =>
          K.T {name = name,
               prop = prop,
               stms = deleteStms stms,
               transfer = transfer,
               successors = successors}
  
  fun deleteStmBlocks bs = List.map deleteStmBlock bs
  
  fun lookupDeadBlock bs =
      case bs
       of [] => ()        
        | x as K.T {name,
               prop,
               stms,
               transfer,
               successors} :: xs =>
          if liveBlock name
          then lookupDeadBlock xs
          else (case successors
                of [] => ()
                 | [succ] =>
                   setJump (name, SOME succ)
                 | [succ1, succ2] =>
                   if Id.equals (succ1, succ2)
                   then setJump (name, SOME succ1)
                   else if Id.equals (name, succ1)
                        then setJump (name, SOME succ2)
                        else setJump (name, SOME succ1)
                 | _ => raise Fail "compiler bug: more than two successors"
                ; lookupDeadBlock xs)
  
  val changedBlocks = ref false
  
  fun realDeleteBlocks bs =
      case bs
       of [] => []        
        | x as K.T {name,
               prop,
               stms,
               transfer,
               successors} :: xs =>
          if liveBlock name
          then let fun adjust x =
                       case jump x
                        of NONE => x
                         | SOME y => y
                   fun doSuccs succs = List.map adjust succs
                   fun doTransfer j =
                       case j
                        of J.Jump {line, label} =>
                           J.Jump {line = line, label = adjust label}
                         | J.If {line, value, truee, falsee} =>
                           J.If {line = line, value = value, truee = adjust truee, falsee = adjust falsee}
                         | J.Return {line, value} =>
                           J.Return {line = line, value = value}
                   val transfer = doTransfer transfer
                   val successors = doSuccs successors
                   val new = K.T {name = name,
                                  prop = prop,
                                  stms = stms,
                                  transfer = transfer,
                                  successors = successors}
               in  new :: (realDeleteBlocks xs)
               end
          else let val _ = debugPrint (String.concat ["delete a block: ", Id.toString name, "\n"])
                   val _ = changedBlocks := true
               in  realDeleteBlocks xs
               end
              
  fun deleteBlockBlocks bs =
      let val _ = lookupDeadBlock bs
          fun doit bs = realDeleteBlocks bs
          fun doits bs =
              let val new = doit bs
              in  if !changedBlocks
                  then (changedBlocks := false; doits new)
                  else new
              end
          val bs' = doits bs
      in  bs'
      end
  
  fun calculateCdg (rcfg : Id.t DiGraph.t, getName : Id.t DiGraph.Node.t -> Id.t, df) =
      let val nodes = DiGraph.nodes rcfg
          val cdg = DiGraph.new ()
          val {get = getCdgName, set = setCdgName, destroy = destroyCdgName, ...} :
              {get : Id.t DiGraph.Node.t -> Id.t option, set : Id.t DiGraph.Node.t * Id.t option -> unit,
               destroy : unit -> unit} =
              Property.destGetSet (DiGraph.Node.plist, Property.initConst NONE)
          fun addNodes l =
              case l
               of [] => ()
                | x :: xs =>
                  let val new = DiGraph.newNode cdg
                      val name = getName x
                      val _ = setCdgName (new, SOME name)
                  in  addNodes xs
                  end
          val _ = addNodes nodes
          
          fun addEdges l =
              case l
               of [] => ()
                | x :: xs =>
                  let val df = df x
                      val to = DiGraph.lookup (cdg, fn m => Id.equals (valOf (getCdgName m), getName x))
                      fun loopDf ll =
                          case ll
                           of [] => ()
                            | y :: ys =>
                              let val from = DiGraph.lookup (cdg, fn m =>
                                                                   Id.equals (valOf (getCdgName m), getName y))
                                  val _ = DiGraph.addEdge (cdg, {from = from, to = to})
                              in  loopDf ys
                              end
                      val _ = loopDf df
                  in  addEdges xs
                  end
          val _ = addEdges nodes
          val _ = debugPrint "calculate CDG finished\n"
      in  {cdg = cdg, getCdgName = valOf o getCdgName}
      end       
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val rname = Id.new ()
              val r = K.T {name = rname,
                           prop = true,
                           stms = [],
                           transfer = J.If {line = Counter.next (),
                                            value = O.Null,
                                            truee = name,
                                            falsee = exit},
                           successors = [name, exit]}
              val newF = F.addBlock (f, r)
              val _ = debugPrint "to here: just after newF\n"
              val {graph = rCfg, getName = getNameRcfg} =
                  F.toReverseGraph newF
              val _ = debugPrint "to here: just after reverse\n"
              val startNode = DiGraph.lookup (rCfg, fn x => Id.equals (exit, getNameRcfg x))
              val _ = debugPrint "to here: just after startNode\n"
              val _ = if tag
                      then DiGraph.toDot (rCfg, "rcfg", Id.toString o getNameRcfg)
                      else ()
              val {get = df, set = setDf, destroy = destroyDf, ...} =
                  Property.destGetSet (DiGraph.Node.plist, Property.initConst [])
              val _ = DiGraph.calculateDf (rCfg, startNode, df, setDf, fn x => "")
              val {cdg : Id.t DiGraph.t, getCdgName : Id.t DiGraph.Node.t -> Id.t} =
                  calculateCdg (rCfg, getNameRcfg, df)
              val _ = if tag
                      then DiGraph.toDot (cdg, "cdg", Id.toString o getCdgName)
                      else ()
              val _ = debugPrint "to here: just before doit ()\n"
              fun doit () = (annotateLiveBlocks (cdg, getCdgName, blocks)
                            ; setLiveBlockTransfer blocks)
              fun doits () =
                  let val _ = doit ()
                  in  if !changed
                      then (changed := false
                          ; doits ())
                      else ()
                  end
              val _ = doits ()
              val _ = setLiveBlock (name, true)
              (*
              val blocks = deleteBlockBlocks blocks
              *)
              val blocks = deleteStmBlocks blocks
              val new = F.T {name = name,
                             exit = exit, 
                             rettype = rettype,
                             args = args,
                             locals = locals,
                             blocks = blocks,
                             pre = pre,
                             post = post}
              val _ = destroy ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\nagressive dead code elemination starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\nagressive dead code elemination finished\n"
      in  new
      end
end
